home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PASWIZ20 / STRINGS.PAS < prev    next >
Pascal/Delphi Source File  |  1994-11-04  |  10KB  |  407 lines
  1. {   +----------------------------------------------------------------------+
  2.     |                                                                      |
  3.     |        PasWiz  Copyright (c) 1990-1994  Thomas G. Hanlin III         |
  4.     |                                                                      |
  5.     +----------------------------------------------------------------------+
  6.  
  7.  
  8.  
  9. Strings:
  10.  
  11.    This unit provides extensions to Pascal's rather minimal string support.
  12.    This includes string trimming, substring extraction, uppercase/lowercase
  13.    conversions (handles names, too), simple encryption and compression,
  14.    assorted searches, advanced comparisons, and other useful tools.
  15.  
  16. }
  17.  
  18.  
  19.  
  20. UNIT Strings;
  21.  
  22.  
  23.  
  24. INTERFACE
  25.  
  26.  
  27.  
  28. FUNCTION Bickel (St1, St2: String): Integer;
  29. FUNCTION BSq (St: String): String;
  30. FUNCTION BUsq (St: String): String;
  31. FUNCTION Cipher (St, Passwd: String): String;
  32. FUNCTION CipherP (St, Passwd: String): String;
  33. FUNCTION Crunch (SubSt, St: String): String;
  34. FUNCTION Dupe (Count: Integer; SubSt: String): String;
  35. FUNCTION Extract (St, Delimiter: String; Index: Integer): String;
  36. FUNCTION Instr (Start: Integer; SubSt, St: String): Integer;
  37. FUNCTION Left (St: String; Len: Integer): String;
  38. FUNCTION LowerCase (St: String): String;
  39. FUNCTION LTrim (St: String): String;
  40. FUNCTION MatchFile (Pattern, FileName: String): Boolean;
  41. FUNCTION NameCase (St: String): String;
  42. FUNCTION Replace (OldSubSt, NewSubSt, St: String): String;
  43. FUNCTION Reverse (St: String): String;
  44. FUNCTION Right (St: String; Len: Integer): String;
  45. FUNCTION RPos (SubSt, St: String): Integer;
  46. FUNCTION RTrim (St: String): String;
  47. FUNCTION Soundex (St: String): String;
  48. FUNCTION StripCh (ChList, St: String): String;
  49. FUNCTION StripSt (SubSt, St: String): String;
  50. FUNCTION StripType (ChType: Integer; St: String): String;
  51. FUNCTION TypePos (ChType: Integer; St: String): Integer;
  52. FUNCTION UpperCase (St: String): String;
  53.  
  54.  
  55.  
  56. { --------------------------------------------------------------------------- }
  57.  
  58.  
  59.  
  60. IMPLEMENTATION
  61.  
  62.  
  63.  
  64. {$F+}
  65.  
  66. { routines in assembly language }
  67.  
  68. FUNCTION Bickel; external;           { string comparison by Bickel method }
  69. {$L BICKEL}
  70.  
  71. FUNCTION LowerCase; external;        { convert to lowercase }
  72. {$L LOCASE}
  73.  
  74. FUNCTION MatchFile; external;        { see if filename matches wildcard spec }
  75. {$L MATCHFIL}
  76.  
  77. FUNCTION NameCase; external;         { capitalize a name appropriately }
  78. {$L NAMECASE}
  79.  
  80. FUNCTION UpperCase; external;        { convert to uppercase }
  81. {$L UPCASE}
  82.  
  83. FUNCTION Reverse; external;          { reverse a string }
  84. {$L REVERSE}
  85.  
  86. FUNCTION Soundex; external;          { string comparison by Soundex method }
  87. {$L SOUNDEX}
  88.  
  89. FUNCTION TypePos; external;          { seek a given type of character }
  90. {$L TYPEPOS}
  91.  
  92.  
  93.  
  94. { compress spaces in a string }
  95. FUNCTION BSq (St: String): String;
  96. VAR
  97.    SqSt: String;
  98.    Ptr, RepCount: Integer;
  99. BEGIN
  100.    SqSt := '';
  101.    RepCount := 0;
  102.    FOR Ptr := 1 TO Length(St) DO
  103.       IF St[Ptr] = ' ' THEN
  104.          INC(RepCount)
  105.       ELSE BEGIN
  106.          CASE RepCount OF
  107.             0: ;
  108.             1: IF Ptr = 2 THEN
  109.                   SqSt := ' '
  110.                ELSE
  111.                   SqSt[Length(SqSt)] := CHR(ORD(SqSt[Length(SqSt)]) OR $80);
  112.             2: SqSt := SqSt + CHR(ORD(' ') OR $80);
  113.             ELSE SqSt := SqSt + CHR($80) + CHR((RepCount - 3) OR $80);
  114.          END;
  115.          SqSt := SqSt + St[Ptr];
  116.          RepCount := 0;
  117.       END;
  118.    { flush any remaining spaces }
  119.    CASE RepCount OF
  120.       0: ;
  121.       1: IF St = ' ' THEN
  122.             SqSt := ' '
  123.          ELSE
  124.             SqSt[Length(SqSt)] := CHR(ORD(SqSt[Length(SqSt)]) OR $80);
  125.       2: SqSt := SqSt + CHR(ORD(' ') OR $80)
  126.       ELSE SqSt := SqSt + CHR($80) + CHR((RepCount - 3) OR $80);
  127.    END;
  128.    BSq := SqSt;
  129. END;
  130.  
  131.  
  132.  
  133. { uncompress a string processed by BSq }
  134. FUNCTION BUsq (St: String): String;
  135. VAR
  136.    UnsqSt: String;
  137.    Ptr: Integer;
  138. BEGIN
  139.    UnsqSt := '';
  140.    Ptr := 1;
  141.    WHILE Ptr <= Length(St) DO
  142.       CASE ORD(St[Ptr]) OF
  143.          0..$7F:    { ordinary chars }
  144.             BEGIN
  145.                UnsqSt := UnsqSt + St[Ptr];
  146.                INC(Ptr);
  147.             END;
  148.          $80:       { RLE sequence }
  149.             BEGIN
  150.                UnsqSt := UnsqSt + Dupe((ORD(St[Ptr + 1]) AND $7F) + 3, ' ');
  151.                INC(Ptr, 2);
  152.             END;
  153.          $81..$FF:  { character followed by one space }
  154.             BEGIN
  155.                UnsqSt := UnsqSt + CHR(ORD(St[Ptr]) AND $7F) + ' ';
  156.                INC(Ptr);
  157.             END;
  158.       END;
  159.    BUsq := UnsqSt;
  160. END;
  161.  
  162.  
  163.  
  164. { encipher or decipher a string }
  165. FUNCTION Cipher (St, Passwd: String): String;
  166. VAR
  167.    SPtr, PPtr: Integer;
  168. BEGIN
  169.    IF Length(Passwd) > 0 THEN BEGIN
  170.       PPtr := 1;
  171.       FOR SPtr := 1 TO Length(St) DO BEGIN
  172.          St[SPtr] := CHR(Ord(St[SPtr]) XOR Ord(Passwd[PPtr]));
  173.          INC(PPtr);
  174.          IF PPtr > Length(Passwd) THEN
  175.             PPtr := 1;
  176.       END;
  177.    END;
  178.    Cipher := St;
  179. END;
  180.  
  181.  
  182.  
  183. { encipher or decipher a string, with printable results }
  184. FUNCTION CipherP (St, Passwd: String): String;
  185. VAR
  186.    SPtr, PPtr: Integer;
  187. BEGIN
  188.    IF Length(Passwd) > 0 THEN BEGIN
  189.       PPtr := 1;
  190.       FOR SPtr := 1 TO Length(St) DO BEGIN
  191.          St[SPtr] := CHR(Ord(St[SPtr]) XOR Ord(Passwd[PPtr]) XOR $80);
  192.          INC(PPtr);
  193.          IF PPtr > Length(Passwd) THEN
  194.             PPtr := 1;
  195.       END;
  196.    END;
  197.    CipherP := St;
  198. END;
  199.  
  200.  
  201.  
  202. { remove adjacent occurrences of a given substring from a string }
  203. FUNCTION Crunch (SubSt, St: String): String;
  204. VAR
  205.    Two: String;
  206.    Posn: Integer;
  207. BEGIN
  208.    IF Length(SubSt) > 0 THEN BEGIN
  209.       Two := SubSt + SubSt;
  210.       REPEAT
  211.          Posn := Pos(Two, St);
  212.          IF Posn > 0 THEN
  213.             Delete(St, Posn, Length(SubSt));
  214.       UNTIL Posn = 0;
  215.    END;
  216.    Crunch := St;
  217. END;
  218.  
  219.  
  220.  
  221. { form a string of repeated substrings }
  222. FUNCTION Dupe (Count: Integer; SubSt: String): String;
  223. VAR
  224.    St: String;
  225. BEGIN
  226.    St := '';
  227.    WHILE Count > 0 DO BEGIN
  228.       St := St + SubSt;
  229.       DEC(Count);
  230.    END;
  231.    Dupe := St;
  232. END;
  233.  
  234.  
  235.  
  236. { extract a substring from a string partitioned by delimiters }
  237. FUNCTION Extract (St, Delimiter: String; Index: Integer): String;
  238. VAR
  239.    Start, SLen, Posn: Integer;
  240. BEGIN
  241.    Start := 1;
  242.    IF (Index > 0) AND (Length(Delimiter) > 0) THEN BEGIN
  243.       REPEAT
  244.          Posn := Instr(Start, Delimiter, St);
  245.          DEC(Index);
  246.          IF Index = 0 THEN
  247.             IF Posn > 0 THEN
  248.                SLen := Posn - Start
  249.             ELSE
  250.                SLen := Length(St) - Start + 1
  251.          ELSE IF Posn = 0 THEN
  252.             SLen := 0
  253.          ELSE
  254.             Start := Posn + Length(Delimiter);
  255.       UNTIL (Posn = 0) OR (Index = 0);
  256.    END
  257.    ELSE
  258.       SLen := 0;
  259.    Extract := Copy(St, Start, SLen);
  260. END;
  261.  
  262.  
  263.  
  264. { search for a substring within a string (like Pos but with start position) }
  265. FUNCTION Instr (Start: Integer; SubSt, St: String): Integer;
  266. VAR
  267.    Posn: Integer;
  268. BEGIN
  269.    Posn := Pos(SubSt, Copy(St, Start, 255));
  270.    IF Posn > 0 THEN
  271.       Posn := Posn + Start - 1;
  272.    Instr := Posn;
  273. END;
  274.  
  275.  
  276.  
  277. { return part of a string starting from the left side }
  278. FUNCTION Left (St: String; Len: Integer): String;
  279. BEGIN
  280.    Left := Copy(St, 1, Len);
  281. END;
  282.  
  283.  
  284.  
  285. { trim blanks from the left side of a string }
  286. FUNCTION LTrim (St: String): String;
  287. BEGIN
  288.    WHILE Copy(St, 1, 1) = ' ' DO
  289.       Delete(St, 1, 1);
  290.    LTrim := St;
  291. END;
  292.  
  293.  
  294.  
  295. { replace a given substring with another }
  296. FUNCTION Replace (OldSubSt, NewSubSt, St: String): String;
  297. VAR
  298.    Tmp: String;
  299.    Posn: Integer;
  300. BEGIN
  301.    IF Length(OldSubSt) > 0 THEN BEGIN
  302.       Tmp := '';
  303.       REPEAT
  304.          Posn := Pos(OldSubSt, St);
  305.          IF Posn > 0 THEN BEGIN
  306.             Tmp := Tmp + Copy(St, 1, Posn - 1) + NewSubSt;
  307.             Delete(St, 1, Posn + Length(OldSubSt) - 1);
  308.          END
  309.          ELSE
  310.             Tmp := Tmp + St;
  311.       UNTIL Posn = 0;
  312.       Replace := Tmp;
  313.    END
  314.    ELSE
  315.       Replace := St;
  316. END;
  317.  
  318.  
  319.  
  320. { return part of a string starting from the right side }
  321. FUNCTION Right (St: String; Len: Integer): String;
  322. BEGIN
  323.    IF Len >= Length(St) THEN
  324.       Right := St
  325.    ELSE
  326.       Right := Copy(St, Length(St) - Len + 1, 255);
  327. END;
  328.  
  329.  
  330.  
  331. { search for a substring, starting from the right side of a string }
  332. FUNCTION RPos (SubSt, St: String): Integer;
  333. VAR
  334.    Posn: Integer;
  335. BEGIN
  336.    Posn := Pos(Reverse(SubSt), Reverse(St));
  337.    IF Posn > 0 THEN
  338.       Posn := Length(St) - Length(SubSt) - Posn + 2;
  339.    RPos := Posn;
  340. END;
  341.  
  342.  
  343.  
  344. { trim blanks from the right side of a string }
  345. FUNCTION RTrim (St: String): String;
  346. BEGIN
  347.    WHILE Copy(St, Length(St), 1) = ' ' DO
  348.       Delete(St, Length(St), 1);
  349.    RTrim := St;
  350. END;
  351.  
  352.  
  353.  
  354. { strip all occurrences of a list of characters from a string }
  355. FUNCTION StripCh (ChList, St: String): String;
  356. VAR
  357.    Ptr: Integer;
  358.    Tmp: String;
  359. BEGIN
  360.    Tmp := '';
  361.    IF Length(ChList) > 0 THEN
  362.       FOR Ptr := 1 TO Length(St) DO
  363.          IF Pos(St[Ptr], ChList) = 0 THEN
  364.             Tmp := Tmp + St[Ptr];
  365.    StripCh := Tmp;
  366. END;
  367.  
  368.  
  369.  
  370. { strip all occurrences of a substring from a string }
  371. FUNCTION StripSt (SubSt, St: String): String;
  372. VAR
  373.    Posn: Integer;
  374. BEGIN
  375.    IF (Length(St) = 0) OR (Length(SubSt) = 0) THEN
  376.       StripSt := ''
  377.    ELSE BEGIN
  378.       REPEAT
  379.          Posn := Pos(SubSt, St);
  380.          IF Posn > 0 THEN
  381.             Delete(St, Posn, Length(SubSt));
  382.       UNTIL Posn = 0;
  383.       StripSt := St;
  384.    END;
  385. END;
  386.  
  387.  
  388.  
  389. { strip all occurrences of given types of character from a string }
  390. FUNCTION StripType (ChType: Integer; St: String): String;
  391. VAR
  392.    Posn: Integer;
  393. BEGIN
  394.    REPEAT
  395.       Posn := TypePos(ChType, St);
  396.       IF Posn > 0 THEN
  397.          Delete(St, Posn, 1);
  398.    UNTIL Posn = 0;
  399.    StripType := St;
  400. END;
  401.  
  402.  
  403.  
  404. { ----------------------- initialization code --------------------------- }
  405. BEGIN
  406. END.
  407.